;;########################################################################
;; workmap5.lsp 
;; DRAG-ICON, ADD-ICON, DRAW-LOGO, CLOSE, ETC.
;; Copyright (c) 1992-2002 by Forrest W. Young
;;#######################################################################



(defmeth workmap-proto :drag-icon 
          (i x y iconx icony colpix rowpix xoff yoff shift)
;i=icon number.
;x and y locations of click
;iconx icony lists of old x y locs of upleft corner all icons
;colpix rowpix=sizes of icon i
;xoff yoff=locations moving icon i from
;shift=t if move tree
  (let* ((oldlocx (select iconx i))
         (oldlocy (select icony i))
         (offsetx (- oldlocx x))
         (offsety (- oldlocy y))
         (xoff2 0)
         (added-width 0)
         (ic (select (send self :icon-list) i))
         (tw (+ 6 (send self :text-width 
                        (send self :displayed-icon-title (send ic :title)))))
         (icon-type (send ic :icon-type))
         (th (send self :text-ascent) (send self :text-descent))
         (bar-bottom (+ 30 th))
         (scrolly (second (send self :scroll)))
         (w)
         (h)
         (oldxy)
         (newxy)
         (knt 0)
         (draw-flag)
         (last-draw)
         (savedx) (savedy)
         (icon-obj (select (send self :icon-list) i))
         (drag-icon-image? *drag-icon-image*)
         )
    
    (cond 
      ((= icon-type 2) (setf xoff2 0) )
      (t (when (or (send self :new-icon-style?) (send self :show-icon-ears?))
               (setf added-width 36) (setf xoff2 -18))))
    (setf xoff2 (min xoff2 (- (ceiling (/ (- colpix tw) 2)) 0)))
    (setf w (max tw (+ colpix added-width)))
    (setf h (+ rowpix th 6))
    (setf oldxy (list x y w h))
    (setf lastxy (list x y))
    (flet ((fake-draw-grey-rect 
            (x y)
            (when (or (> (abs (- (first oldxy) x)) 5)
                      (> (abs (- (second oldxy) y)) 5))
                  (setf draw-flag t)
                  )
            (when draw-flag 
                  (when savedx 
                        (send self :frame-rect 
                              (+ savedx offsetx xoff2) 
                              (+ savedy offsety) w h))
                  (send self :frame-rect (+ x offsetx xoff2) (+ y offsety) w h )
                  (setf newxy (list (+ x offsetx xoff2) (+ y offsety) w h))
                  (setf savedx x)
                  (setf savedy y)
                  ))
            
           (drag-icon-image 
            (x y)
            (when (or (> (abs (- (first oldxy) x)) 5)
                      (> (abs (- (second oldxy) y)) 5))
                  (send self :erase-rect 
                              (+ (first oldxy) offsetx xoff2) 
                              (+ (second oldxy) offsety) (+ 1 w) (+ 1 h))
                  (setf draw-flag t)
                  )
            (when draw-flag 
                  (when savedx 
                        (send self :clip-rect 
                              (+ savedx offsetx xoff2 (- (round (/ tw 2))))
                              (+ savedy offsety -8) (+ 3 (* 2 tw)) (+ 12 h)))
                  (send icon-obj :x (+ x offsetx ))
                  (send icon-obj :y (+ y offsety))
                  (send icon-obj :show-icon (send icon-obj :state))
                  (send self :redraw-content)
                  (apply #'send self :clip-rect (send self :view-rect))
                  (setf newxy (list (+ x offsetx xoff2) (+ y offsety) w h))
                  (setf savedx x)
                  (setf savedy y)
                  (setf lastxy (list x y))
                  )
            
            ))
      (cond
        (drag-icon-image?
         (send self :while-button-down #'drag-icon-image))
        (t
         (send self :draw-mode 'xor) 
         (send self :while-button-down #'fake-draw-grey-rect)
         (send self :draw-mode 'normal)
         )))
    (when newxy
;(print (list "newxy" newxy))
          (when (< (first newxy) 4) (setf (first newxy) 4))
          (when (> (first newxy) (- (^ 2 12) 100)) (setf (first newxy) 4))
          (when (< (second newxy) 0) (setf (second newxy) 0))
          (when (> (second newxy) (- (^ 2 12) 100)) (setf (second newxy) 0))
          (when (and (< (second newxy) bar-bottom)
                     (equal self *workmap*)
                     (send self :toolbar))
                (setf (second newxy) bar-bottom))
          (setf offsetx (- oldlocx (- xoff2) (select newxy 0)))
          (setf offsety (- oldlocy (select newxy 1)))
          (send self :move-icon-tree i offsetx offsety iconx icony shift)
          (dotimes (iconnum (send self :num-icons))
                   (send (select (send self :icon-list) iconnum) :moved-p nil))
          (send self :check-scroll-bars)
          (when (or (/= (- (first newxy) xoff2) xoff) 
                    (/= (second newxy) yoff))
                (send self :redraw));!!!!!!!!!!!
          )
    ;(when (not newxy) (setf newxy oldxy))
    ;(> 3 (max (abs (- newxy oldxy))))
    draw-flag
    ))

(defmeth workmap-proto :drag-icon? (icon-number x y m1)
  (let* ((icon (select (send self :icon-list) icon-number))
         (iconx (send self :x))
         (icony (send self :y))
         (ix (select iconx icon-number))
         (iy (select icony icon-number))
         (rowpix (send icon :height))
         (colpix (send icon :width))
         (dragged-it?
          (send self :drag-icon 
                icon-number x y iconx icony colpix rowpix ix iy m1)))
    dragged-it?))


(defmeth workmap-proto :drag-icon-bitmap (hot-icon-num x y m1)
  (let* ((oldx (send self :x))
         (oldy (send self :y))
         (hot-icon-objid (select (send self :icon-list) hot-icon-num))
         )
    (format nil "~d ~d ~d ~d~%" oldx oldy x y)
    (send self :draw-mode 'xor)
    (send hot-icon-objid :show-icon (send hot-icon-objid :icon-state))
    (send self :x x)
    (send self :y y)
    (send hot-icon-objid :show-icon (send hot-icon-objid :icon-state))
    (send self :draw-mode 'normal)
    ))


(defmeth workmap-proto :move-icon-tree (i offsetx offsety iconx icony shift)
  (let ((icon-i (select (send self :icon-list) i))
        )
    (setf (select iconx i) (- (select iconx i) offsetx))
    (setf (select icony i) (- (select icony i) offsety))
    (send icon-i :x (select iconx i))
    (send icon-i :y (select icony i))
    (send icon-i :moved-p t)
    )
  (when shift 
        (let ((connected-icons (select (send self :connection-list) i))
              )
          (when (select connected-icons 0)
                (dolist 
                 (j connected-icons)
                 (when 
                  (not (send (select (send self :icon-list) j) :moved-p))
                  (send self :move-icon-tree 
                        j offsetx offsety iconx icony shift)))
                ))))

;add-connected icon is in workmap1.lsp

;the object keywords on each (send icon-xxx :new) line in add-icon
;are not completely implemented. this hack is used insted

(defmeth workmap-proto :add-icon (w x y title icon-type 
                                    &optional data-type array 
                                    &key draw object (implied-icon-type 0))
  ;(FORMAT T "; WORKMAP5.LSP|ADD-ICON: ICON-TYPE=~A OBJECT=~A"ICON-TYPE OBJECT)
  (send self :redraw-order 
        (append (send self :redraw-order) (list (send self :num-icons))))
  (send self :num-icons (+ 1 (send self :num-icons)))
  (send self :x (append (send self :x) (list x)))
  (send self :y (append (send self :y) (list y)))
  (send self :icon-title (append (send self :icon-title) (list (send object :proper-name))))
 ; (send self :icon-title (append (send self :icon-title) (list title)))
  (send self :icon-type (append (send self :icon-type) (list icon-type)))
  (send self :connections-to-me 
         (add-element-to-list (send self :connections-to-me) '(nil)))
  (send self :deleted? (add-element-to-list (send self :deleted?) nil))
  (cond 
    ((or (= 1 icon-type)  ;when mv-data-icon
         (= 4 icon-type)  ;when diss-data-icon
         (= 9 icon-type)  ;when dash icon implying data object
         )
     (send self :num-data-icons (+ 1 (send self :num-data-icons)))
     (send self :selected-data-icon (- (send self :num-icons) 1))
     (if (and (equal (send object :data-type) "missing") 
              (equal (send object :real-data-type) "new"))
         (setf data-type "new"))
     (send self :icon-list (append (send self :icon-list)
                 (when (= 1 icon-type)          ; data-icon
                       (list (send dob-icon-proto :new w x y 25 32 
                             :title title :draw nil :array array
                             :object object ;fwy added 09-09-02
                  	     :data-type data-type)))
                    	   ; :dash-icon (send object :dash-icon) makes no sense
                 (when (= 4 icon-type)          ; diss-data-icon
                       (list (send dib-icon-proto :new w x y 25 32 
                             :object object ;fwy added 09-09-02
                             :title title  :draw nil)))
                 (when (= 9 icon-type) ;dash-data-icon
                       (list (send dash-icon-proto :new w x y 45 33 
                                    :title title :state "selected" :draw t
                                    :object object)))))
     (send self :data-icon-number-list (append 
                 (send self :data-icon-number-list)
                 (list (- (send self :num-icons)1))))
     (send self :data-icon-list (append (send self :data-icon-list)
                 (list (select (send self :icon-list) 
                               (- (send self :num-icons) 1)))))
     (send (select (send self :icon-list) (- (send self :num-icons) 1))
           :icon-number (send self :num-data-icons)))
    ((or (= 2 icon-type)  (< 5 icon-type) ) ;when tool/guide
     (send self :icon-list 
           (append (send self :icon-list)
                   (case icon-type
                     (2 ;tool-icon for transformations
                        (list (send tool-icon-proto :new w x y 45 13 
                             :object object ;fwy added 09-09-02
                                    :title title :state "selected" :draw nil)))
                     (6 ;guide-icon
                        (list (send guide-icon-proto :new w x y 45 13 
                                    :title title :draw t)))
                     (7 ;and-icon
                        (list (send and-icon-proto :new w x y 45 13 
                                    :title title :draw t)))
                     (9 ;dash-icon - only when not standing for data - shouldnt happen
                        (FORMAT T "~%; WORKMAP5.LSP|ADD-ICON: BAD-ICON-TYPE=9 ~A ~%" OBJECT)
                        ))))
     (send (select (send self :icon-list) (- (send self :num-icons) 1))
           :icon-number (1- (send self :num-icons)))
     )
    ((= 3 icon-type)  ;when model-icon
     (send self :num-model-icons (+ 1 (send self :num-model-icons)))
     (send self :icon-list (append (send self :icon-list)
                 (list (send mob-icon-proto :new w x y 25 32 
                             :title title :draw nil :object object))))
     (send self :model-icon-number-list (append 
                 (send self :model-icon-number-list)
                 (list (- (send self :num-icons) 1))))
     (send self :model-icon-list (append (send self :model-icon-list)
                 (list (select (send self :icon-list) 
                               (- (send self :num-icons) 1)))))
     (send (select (send self :icon-list) (- (send self :num-icons) 1))
           :icon-number (send self :num-model-icons)))
    )
  (send self :selected-icon (- (send self :num-icons) 1))
  (let ((n (send self :num-icons)))
    (if (= n 1) 
        (send self :connection-list (list (list nil)))
        (send self :connection-list 
              (append (select (send self :connection-list) (iseq (- n 1)))
                      (list (list nil))))))
  (send self :check-scroll-bars)
  ;(select (send self :icon-list) (send self :selected-icon))
  ;following let replaces line above - fwy 09-09-02
  ;the object keywords on each (send icon-xxx :new) line above
  ;are not completely implemented. this hack is used insted
  (let ((icon (select (send self :icon-list) 
                      (send self :selected-icon))))
    (unless (= 9 icon-type) (send icon :object object))
   ; (format t 
   ;   "; workmap5.lsp - add-icon - icon's object slot is ~a~%" 
   ;      object)
    icon)
  )



(defmeth workmap-proto :close ()
;;#+msdos     (send self :hide-window)
#-macintosh (send self :hide-window)
#+macintosh (send self :gui nil)
  )

(defmeth workmap-proto :show-window ()
  (call-next-method)
  (send self :redraw))

(defmeth workmap-proto :load-object (file)
"Args: (file)
Loads a data object contained in FILE."
  (setf file (string-downcase-if-not-X11 file))
  (let* ((pstn (position #\\ (reverse file)))
         (short-filename (reverse (subseq (reverse file) 0 pstn)))
         (directory (subseq file 0 (- (length file) 1 pstn)))
         (indir (format t "; InDir:  ~a~%" directory))
         (dummy (format t "> ; InFile: ~a;" short-filename))
         (start (get-internal-real-time))
         (elapsed) (short-filename)
         (f (open (string file)))
         (file-length (file-length f))
         (stream nil)
         (object nil))
    (setf stream (read f))
    (setf elapsed (/ (- (get-internal-real-time) start)
                     internal-time-units-per-second))
    (format t " ~,3f Seconds; ~d Bytes~%> "
          (fuzz elapsed 3) file-length )
    (send self :datafile file)
    (setf object (eval stream))
    (send self :datafile "[Not Saved To DataFile]")
    (close f)
    object))

(defmeth workmap-proto :datafile (&optional (str nil set))
"Message args: (&optional str)
 Sets or retrieves the datafile string."
  (when (not (send self :has-slot 'datafile))(send self :add-slot 'datafile '"[Not Saved To DataFile]"))
  (if set (setf (slot-value 'datafile) str))
  (slot-value 'datafile))

(defmeth workmap-proto :initialize-file-menu (&optional previous-data)
  (send new-data-file-menu-item       :enabled t);line added
  (send open-data-file-menu-item      :enabled t)
  (send simulate-data-file-menu-item  :enabled t)
  (send import-data-file-menu-item    :enabled t)
  (cond
    (*current-data* ;was previous-data
     (send export-data-file-menu-item    :enabled t)
     (send save-data-menu-item           :enabled t))
    (t
     (send export-data-file-menu-item    :enabled nil)
     (send save-data-menu-item           :enabled nil)))
  (if *current-model*
     (send save-model-menu-item          :enabled t)
     (send save-model-menu-item          :enabled nil))
  t)

(defmeth workmap-proto :initialize-data-menu ()
  (send *tools-menu* :enabled t)
  (send visualize-data-menu-item  :enabled t)
  (send summarize-data-menu-item  :enabled t)
  (send save-data-menu-item       :enabled t)
  (send export-data-file-menu-item :enabled t)
  (send delete-data-menu-item     :enabled t)
  (send create-dob-data-menu-item :enabled t)
  (send show-datasheet-menu-item  :enabled t)
  (send show-obs-menu-item        :enabled t)
  (send show-vars-menu-item       :enabled t)
  (send report-data-menu-item     :enabled t)
  (send browse-data-menu-item     :enabled t)
  )

(defmeth workmap-proto :initialize-trans-menu ()
  (send *trans-menu* :enabled t))

(defmeth workmap-proto :enabled-trans-menu (tnil)
"Enables or disabled all items of the transformation menu"
  (let* ((items (send *trans-menu* :items))
         (num-items (length items)))
    (mapcar #'(lambda (i)
                (send (select items i) :enabled tnil))
            (iseq num-items)))
  (send *trans-menu* :enabled tnil)
  tnil)

(defmeth workmap-proto :initialize-model-menu ()
  ;(send guide-model-menu-item :enabled t)
  (send visualize-model-menu-item :enabled t)
  (send report-model-menu-item :enabled t)
  (send save-model-menu-item :enabled t)
  (if (or (equal (send *current-model* :title) "Univariate Analysis")
          (equal (send *current-model* :title) "Analysis of Variance"))
      (send interpret-model-menu-item :enabled t)
      (send interpret-model-menu-item :enabled nil))
  (send create-dataobjects-model-menu-item :enabled t)
  (send delete-model-menu-item :enabled t)
  )

(defun switch-workmap-icon-style ()
  (send *workmap* :new-icon-style? (not (send *workmap* :new-icon-style?)))
  (send *workmap* :redraw)
  (save-desktop-settings))

;========================================================================
; ViSta WorkMap Logo
;========================================================================

(defmeth iconmap-proto :calculate-vista-rect ()
  (let* ((scroll (send self :scroll))
         (has-v-scroll (send self :has-v-scroll))
         (has-h-scroll (send self :has-h-scroll))
         (vr (send self :view-rect))
         (vrx (first vr))
         (vry (second vr))
         (vrw (third vr))
         (vrh (fourth vr))
         (offset-x (+ vrx 12))
         (offset-y (- vry (if has-h-scroll 42 42))) ;42 26
         (toolbar-length (send self :toolbar-length))
         )
    (when (and
           (send self :toolbar)
           (> (first (send self :size)) (+ toolbar-length (if has-v-scroll 140 124))))
          (setf offset-x (+ vrx 10 toolbar-length 
                            (floor (/ (- vrw toolbar-length) 2)) -62))
          (setf offset-y 6))
    (send self :vista-rect (list (- offset-x 8) (- offset-y 6)  125 36))
    (send self :vista-rect)))


(defmeth iconmap-proto :calculate-vista-rect ())

(defmeth iconmap-proto :draw-logo (&key (draw t))
  (let* (;(scroll (send self :scroll))
         (has-v-scroll (send self :has-v-scroll))
         (has-h-scroll (send self :has-h-scroll))
         (vr (send self :view-rect))
         (vrx (first vr))
         (vry (second vr))
         (vrw (third vr))
         (vrh (fourth vr))
        ; (w vrw)
         (offset-x (+ vrx 4))
         (offset-y (- (+ vry vrh) 4 (if has-h-scroll 24 24)));24 8
         (toolbar-length (send self :toolbar-length))
         (polygon-data '(
                      ((4 2) (1 6) (5 5) (6 7) (7 10) (8 12) (9 15) (10 17) (11 20) (12 22) (14 24) (15 22) (16 20) (17 17) (18 15) (19 12) (20 10) (24 2) (37 2) (54 1) (70 1) (87 0) (104 0) (87 0) (70 0) (54 0) (37 0) (24 0) (24 1) (20 6) (17 11) (14 15) (10 11) (7 6) (4 2)) 

                      ((30 24) (37 21) (34 22) (34 20) (34 18) (34 15) (34 13) (33 15) (32 18) (32 20) (31 22) (30 24)) 

                      ((34 11) (34 8) (37 7) (34 11)) 

                      ((45 7) (45 6) (46 5) (48 4) (50 4) (58 4) (64 7) (62 3) (50 3) (48 3) (47 4) (45 4) (44 5) (44 6) (44 8) (45 10) (50 11) (57 13) (60 14) (61 16) (61 18) (60 20) (55 22) (50 22) (47 21) (45 19) (45 17) (46 15) (44 16) (44 18) (43 19) (44 20) (44 22) (45 23) (47 24) (50 24) (54 24) (57 24) (60 22) (61 22) (63 20) (64 18) (64 17) (64 15) (63 14) (62 13) (60 12) (57 11) (54 10) (50 9) (47 8) (46 8) (46 8) (45 7)) 

                      ((74 24) (84 21) (77 22) (77 20) (77 18) (77 15) (77 13) (77 11) (77 9) (76 13) (75 17) (74 21) (74 24)) 

                      ((74 13) (84 11) (74 14) (74 13))
 
                      ((90 24) (94 20) (97 15) (100 20) (104 24) (100 17) (97 9) (94 17) (90 24)) 

                      ((90 21) (97 19) (104 17) (97 18) (90 19) (90 21))))
         (offset-polygon-list)
         (color-type '(nil t t nil t t t t))
         (draw-box-arround-logo nil)
        )

   ; (when (and
   ;        (send self :toolbar)
   ;        (> (first (send self :size)) (+ toolbar-length (if has-v-scroll 140 124))))
   ;      ; (setf draw-box-arround-logo t)
    ;      (setf offset-x (+ vrx 10 toolbar-length 
   ;                         (floor (/ (- vrw toolbar-length) 2)) -62))
   ;       (setf offset-y (+ vry 6)))
    
    (when draw-box-arround-logo
          (send self :draw-color 'white)
          (send self :paint-rect (- offset-x 8) (- offset-y 6)  125 36)
          (send self :draw-color 'black)
          (send self :frame-rect (- offset-x 8) (- offset-y 6)  125 36)
          (send self :frame-rect (- offset-x 6) (- offset-y 4)  121 32)
          )

    (send self :vista-rect (list (- offset-x 8) (- offset-y 6)  125 36))
    (mapcar #'(lambda (polygon-list color-type)
                (setf offset-polygon-list
                      (mapcar #'(lambda (xy-list )
                                  (+ xy-list (list offset-x offset-y)))
                              polygon-list))
                (send self :draw-color 'red);(if color-type 'blue 'red)
                (send self :paint-poly offset-polygon-list)
                (send self :draw-color 'black);(if color-type 'red 'blue) ;red blue
                (send self :frame-poly offset-polygon-list)
                (send self :draw-color 'black))
            polygon-data color-type)))
  





#|Replaced by code above

(defmeth iconmap-proto :draw-logo (&key (draw t))
  (when (and draw (send self :margin))
        (let ((color 'blue)(color2 'red) ;workmap-logo-color
              (lines (send *logo* :lines)))
          (mapcar #'(lambda (i) 
                      (cond
                        ((not (send self :use-color))(setf color 'black))
                        ((= i 3) (setf color 'red)(setf color2 'blue))
                        ((= i 9) (setf color 'blue)(setf color2 'red))
                        ((= i 12) (setf color 'red)(setf color2 'blue));18
                        ((= i 24) (setf color 'red)(setf color2 'blue))
                        )
                      
                      (send self :draw-logo-lines 
                            (list (select lines i) 
                                  (select lines (1+ i))
                                  (select lines (+ i 2))) 
                            :draw t :width 2 :color color :color2 color2))
                  (* 3 (iseq (floor (/ (length lines) 3)))))
          
          )))

  
(defmeth iconmap-proto :calculate-vista-rect ()
  (send self :vista-rect nil)
  (when (send self :margin)
        (let* ((lines (send *logo* :lines))
               (vr (send self :view-rect))
               (h (- (second (send self :size)) 84))
               (rect (mapcar #'(lambda (i) 
                                 (send self :draw-logo-lines 
                                       (list (select lines i) 
                                             (select lines (1+ i))
                                             (select lines (+ i 2))) 
                                       :draw nil :calculate-vista-rect t))
                             (* 3 (iseq (floor (/ (length lines) 3)))))))
          (setf rect (send self :vista-rect))
          (setf rect (list (+ (first rect)  (first vr))
                           (+ (second rect) (second vr) h)
                           (third rect) (fourth rect)))
          (send self :vista-rect rect)
          rect)))

(defmeth iconmap-proto :draw-logo-lines 
  (xyz &key (draw t) width color color2 calculate-vista-rect)
  (let* ((x (first xyz))
         (y (second xyz))
         (h (- (second (send self :size)) 84))
         (scroll (send self :view-rect))
         (scrollx (first scroll))
         (scrolly (second scroll))
         (size (send self :size))
         (nlines (1- (length x)))
         (screen-xy-start (send self :real-to-canvas 
                                (select x 0) (select y 0)))
         (frame-poly-xy (list (+ (list scrollx (+ h scrolly)) screen-xy-start)))
         (screen-xy-end)
         (vista-rect (send self :vista-rect))
         (vista-rect-w  0) (vista-rect-x 10000000)
         (vista-rect-h  0) (vista-rect-y 10000000)
         (color-b4 (send self :draw-color))
         (width-b4 (send self :line-width)))
    (when (and calculate-vista-rect vista-rect)
          (setf vista-rect-x (first  vista-rect))
          (setf vista-rect-y (second vista-rect))
          (setf vista-rect-w (third  vista-rect))
          (setf vista-rect-h (fourth vista-rect)))
    (when draw
          (send self :draw-color color)
          (send self :line-width 1))
    (dotimes (i nlines)
             (setf screen-xy-end (send self :real-to-canvas 
                                       (select x (1+ i)) (select y (1+ i))))
             (setf newx (select screen-xy-start 0))
             (setf newy (select screen-xy-start 1))
             (when calculate-vista-rect
                   
                   (setf vista-rect-x (min vista-rect-x newx))
                   (setf vista-rect-y (min vista-rect-y newy))
                   (setf vista-rect-w 
                         (max vista-rect-w (- newx vista-rect-x)))
                   (setf vista-rect-h 
                         (max vista-rect-h (- newy vista-rect-y)))
                   (send self :vista-rect 
                         (list vista-rect-x vista-rect-y 
                               vista-rect-w vista-rect-h)))
             (setf frame-poly-xy (add-element-to-list
                                  frame-poly-xy (+ (list scrollx (+ h scrolly)) screen-xy-end)))
             (setf screen-xy-start screen-xy-end)) 
    (when draw
          (send self :paint-poly frame-poly-xy )
          (send self :draw-color color2)
          (send self :frame-poly frame-poly-xy)
          (send self :draw-color color-b4)
          (send self :line-width width-b4))
    ))

|#
